home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / glass / glass.lha / GLASS / tmc / cal.ct < prev    next >
Text File  |  1990-11-06  |  27KB  |  1,288 lines
  1. /* 
  2.    Copyright (C) 1990 C van Reewijk, email: dutentb.uucp!reeuwijk
  3.  
  4. This file is part of GLASS.
  5.  
  6. GLASS is free software; you can redistribute it and/or modify
  7. it under the terms of the GNU General Public License as published by
  8. the Free Software Foundation; either version 1, or (at your option)
  9. any later version.
  10.  
  11. GLASS is distributed in the hope that it will be useful,
  12. but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. GNU General Public License for more details.
  15.  
  16. You should have received a copy of the GNU General Public License
  17. along with GLASS; see the file COPYING.  If not, write to
  18. the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19.  
  20. .. file: cal.ct
  21. ..
  22. .. The following variables must be set in tm:
  23. .. basename:     the name of the module. used to generate init_.. and stat_..
  24. .. wantdefs:     the names of the wanted definitions.
  25. ..  OR
  26. .. alldefs:      All code.
  27. ..
  28. .. The following C pre-processor variables must be defined:
  29. .. STAT          If you want code for statistics.
  30. ..               Statistics are written to 'FILE *statstream'.
  31. .. FATAL(msg)    If you want to supply a fatal error handler to print 'msg'.
  32. ..               A default is provided.
  33. .. FIRSTROOM     Initial room in lists. A default is provided.
  34. ..
  35. .. Possible declaration or #define'ing of statstream must be done
  36. .. outside this module.
  37. .error Warning: 'cal' library is obsolete, use 'calu' library.
  38. .error 'cal' does not support reading of NIL pointers.
  39. .if ${index stat_$(basename) $(need_misc)}
  40. .set statcode 1
  41. .else
  42. .set statcode 0
  43. .endif
  44. /* ---- start of ${tplfilename} ---- */
  45.  
  46. /* Routines for '$(basename)'.
  47.  
  48.    template file:      ${tplfilename}
  49.    datastructure file: ${dsfilename}
  50.    tm version:         $(tmvers) ($(tmdate))
  51.  */
  52.  
  53. /* used UNIX functions */
  54. extern char *malloc();
  55. extern char *realloc();
  56.  
  57. .if $(statcode)
  58. #ifdef STAT
  59. .foreach t $(need_stat_list)
  60. static long newcnt_$t_list = 0;
  61. static long frecnt_$t_list = 0;
  62. static long hitcnt_$t_list = 0;
  63. .endforeach
  64.  
  65. .foreach t $(need_stat)
  66. .if ${strlen ${telmlist $t}}
  67. static long newcnt_$t = 0;
  68. static long frecnt_$t = 0;
  69. static long hitcnt_$t = 0;
  70. .else
  71. .foreach c ${conslist $t}
  72. static long newcnt_$c = 0;
  73. static long frecnt_$c = 0;
  74. static long hitcnt_$c = 0;
  75. .endforeach
  76. .endif
  77. .endforeach
  78. #endif
  79.  
  80. .endif
  81.  
  82. /* Caching variables.
  83.  *
  84.  * For each tuple, type list or constructor an array of
  85.  * CACHESZ elements is maintained that is filled by the fre_<type>()
  86.  * routines. If possible new_<type>() uses these elements.
  87.  * all cacheix_<type> variables maintain the index of the first
  88.  * free element in the array.
  89.  */
  90. #ifndef CACHESZ
  91. #define CACHESZ 5
  92. #endif
  93.  
  94. #ifdef USECACHE
  95. #undef USECACHE
  96. #endif
  97.  
  98. #if CACHESZ==0
  99. #else
  100. #define USECACHE
  101. #endif
  102.  
  103. #ifdef USECACHE
  104. .foreach t ${uniq $(need_new_list) $(need_fre_list)}
  105. static short int cacheix_$t_list = 0;
  106. static $t_list cache_$t_list[CACHESZ]; 
  107. .endforeach
  108. .foreach t ${uniq $(need_new) $(need_fre)}
  109. .if ${strlen ${telmlist $t}}
  110. static short int cacheix_$t = 0;
  111. static $t cache_$t[CACHESZ];
  112. .else
  113. .foreach c ${conslist $t}
  114. static short int cacheix_$c = 0;
  115. static $c cache_$c[CACHESZ];
  116. .endforeach
  117. .endif
  118. .endforeach
  119. #endif
  120.  
  121. static char *tm_srcfile = __FILE__;
  122.  
  123. .if ${len $(need_print) $(need_print_list) $(need_fprint) $(need_fprint_list)}
  124. static char tm_niltxt[] = "@";
  125. .endif
  126.  
  127. .if $(statcode)
  128. #ifdef STAT
  129. static char tm_allocfreed[] = "%-15s: %6ld allocated, %6ld freed, %6ld cache hits.%s\n";
  130. #endif
  131. .endif
  132.  
  133. #ifndef FIRSTROOM
  134. /* Default initial room in arrays. (uneducated guess). */
  135. #define FIRSTROOM 2
  136. #endif
  137.  
  138. #ifndef FATAL
  139. #define FATAL(msg) tmfatal(tm_srcfile,__LINE__,msg)
  140. #endif
  141.  
  142. #ifndef WORDBUFSIZE
  143. #define WORDBUFSIZE 100
  144. #endif
  145.  
  146. /* Possible error strings. */
  147. static char tm_outofmemory[] = "out of memory";
  148. .if ${strlen $(need_fscan)}
  149. static char tm_badcons[] = "bad constructor for %s: '%s'";
  150. .endif
  151. .if ${strlen $(need_fscan_list)}
  152. static char tm_badeof[] = "unexpected end of file";
  153. .endif
  154.  
  155. #ifndef FATALTAG
  156. #define FATALTAG(tag) tmbadtag(tm_srcfile,__LINE__,tag)
  157. #endif
  158.  
  159. /* Forward declaration of local routines. */
  160.  
  161. /**************************************************
  162.  *    array room routines                         *
  163.  **************************************************/
  164.  
  165. .foreach t $(need_room_list)
  166. .set stic_$t "static "
  167. .endforeach
  168. .foreach t $(want_room_list)
  169. .set stic_$t
  170. .endforeach
  171. .foreach t $(need_room_list)
  172. /* Announce that you will need room for 'rm' elements in
  173.     $t_list 'l'.
  174.  */
  175. $(stic_$t)void room_$t_list( l, rm )
  176.  register $t_list l;
  177.  register unsigned int rm;
  178. {
  179.     if( l->room>rm ) return;
  180.     l->arr = ($t *) realloc( (char *) l->arr, rm * sizeof(*(l->arr)) );
  181.     if( l->arr == ($t *)0 ){
  182.     FATAL( tm_outofmemory );
  183.     }
  184.     l->room = rm;
  185. }
  186.  
  187. .endforeach
  188. /**************************************************
  189.  *    Allocation routines                         *
  190.  **************************************************/
  191.  
  192. .foreach t $(need_new_list)
  193. .set stic_$t "static "
  194. .endforeach
  195. .foreach t $(want_new_list)
  196. .set stic_$t
  197. .endforeach
  198. .foreach t $(need_new_list)
  199. $(stic_$t)$t_list new_$t_list(){
  200.     $t_list new;
  201.  
  202. #ifdef USECACHE
  203.     if( cacheix_$t_list > 0 ){
  204.     new = cache_$t_list[--cacheix_$t_list];
  205. .if $(statcode)
  206. #ifdef STAT
  207.     hitcnt_$t_list++;
  208. #endif
  209. .endif
  210.     }
  211.     else {
  212. #endif
  213.     new = ($t_list) malloc( sizeof(*new) );
  214.     if( (char *)new == (char *)0 ){
  215.         FATAL( tm_outofmemory );
  216.     }
  217. #ifdef USECACHE
  218.     }
  219. #endif
  220.     new->sz = 0;
  221.     new->arr = ($t *) malloc( FIRSTROOM*sizeof( *(new->arr) ) );
  222.     new->room = FIRSTROOM;
  223.     if( (char *)new->arr == (char *)0 ){
  224.     FATAL( tm_outofmemory );
  225.     }
  226. .if $(statcode)
  227. #ifdef STAT
  228.     newcnt_$t_list++;
  229. #endif
  230. .endif
  231.     return new;
  232. }
  233.  
  234. .endforeach
  235. .foreach t $(need_new)
  236. .set stic_$t "static "
  237. .endforeach
  238. .foreach t $(want_new)
  239. .set stic_$t
  240. .endforeach
  241. .foreach t $(need_new)
  242. .if ${strlen ${telmlist $t}}
  243. $(stic_$t)$t new_$t( ${seplist ", " ${prefix "p_" ${telmlist $t}}} )
  244. .foreach sname ${telmlist $t}
  245. .if ${eq list ${ttypeclass $t $(sname)}}
  246.  ${ttypename $t $(sname)}_list p_$(sname);
  247. .else
  248.  ${ttypename $t $(sname)} p_$(sname);
  249. .endif
  250. .endforeach
  251. {
  252.     register $t new;
  253.  
  254. #ifdef USECACHE
  255.     if( cacheix_$t > 0 ){
  256.     new = cache_$t[--cacheix_$t];
  257. .if $(statcode)
  258. #ifdef STAT
  259.     hitcnt_$t++;
  260. #endif
  261. .endif
  262.     }
  263.     else {
  264. #endif
  265.     new = ($t) malloc( sizeof(*new));
  266.     if( (char *)new == (char *)0 ){
  267.         FATAL( tm_outofmemory );
  268.     }
  269. #ifdef USECACHE
  270.     }
  271. #endif
  272. .foreach sname ${telmlist $t}
  273.     new->$(sname) = p_$(sname);
  274. .endforeach
  275. .if $(statcode)
  276. #ifdef STAT
  277.     newcnt_$t++;
  278. #endif
  279. .endif
  280.     return new;
  281. }
  282.  
  283. .else
  284. .foreach c ${conslist $t}
  285. $(stic_$t)$t new_$c( ${seplist ", " ${prefix "p_" ${celmlist $t $c}}} )
  286. .foreach sname ${celmlist $t $c}
  287. .if ${eq list ${ctypeclass $t $c $(sname)}}
  288.  ${ctypename $t $c $(sname)}_list p_$(sname);
  289. .else
  290.  ${ctypename $t $c $(sname)} p_$(sname);
  291. .endif
  292. .endforeach
  293. {
  294.     register $c new;
  295.  
  296. #ifdef USECACHE
  297.     if( cacheix_$c > 0 ){
  298.     new = cache_$c[--cacheix_$c];
  299. .if $(statcode)
  300. #ifdef STAT
  301.     hitcnt_$c++;
  302. #endif
  303. .endif
  304.     }
  305.     else {
  306. #endif
  307.     new = ($c) malloc( sizeof(*new));
  308.     if( (char *)new == (char *)0 ){
  309.         FATAL( tm_outofmemory );
  310.     }
  311. #ifdef USECACHE
  312.     }
  313. #endif
  314.     new->tag = TAG$c;
  315. .foreach sname ${celmlist $t $c}
  316.     new->$(sname) = p_$(sname);
  317. .endforeach
  318. .if $(statcode)
  319. #ifdef STAT
  320.     newcnt_$c++;
  321. #endif
  322. .endif
  323.     return ($t) new;
  324. }
  325.  
  326. .endforeach
  327. .endif
  328. .endforeach
  329. /**************************************************
  330.  *    Freeing routines                            *
  331.  **************************************************/
  332.  
  333. .foreach t $(need_fre)
  334. .set stic_$t "static "
  335. .endforeach
  336. .foreach t $(want_fre)
  337. .set stic_$t
  338. .endforeach
  339. .foreach t $(need_fre)
  340. .if ${strlen ${telmlist $t}}
  341. /* Free an element of type $t. */
  342. $(stic_$t)void fre_$t( e )
  343.  $t e;
  344. {
  345.     if( e == $tNIL ) return;
  346. .if $(statcode)
  347. #ifdef STAT
  348.     frecnt_$t++;
  349. #endif
  350. .endif
  351. #ifdef USECACHE
  352.     if( cacheix_$t<CACHESZ ){
  353.     cache_$t[cacheix_$t++] = e;
  354.     return;
  355.     }
  356. #endif
  357.     free( (char *) e );
  358. }
  359.  
  360. .else
  361. /* Free an element of type $t. */
  362. $(stic_$t)void fre_$t( e )
  363.  $t e;
  364. {
  365.     if( e == $tNIL ) return;
  366.     switch( e->tag ){
  367. .foreach c ${conslist $t}
  368.     case TAG$c:
  369. .if $(statcode)
  370. #ifdef STAT
  371.         frecnt_$c++;
  372. #endif
  373. .endif
  374. #ifdef USECACHE
  375.         if( cacheix_$c<CACHESZ ){
  376.         cache_$c[cacheix_$c++] = ($c) e;
  377.         break;
  378.         }
  379. #endif
  380.         free( (char *) e );
  381.         break;
  382.  
  383. .endforeach
  384.     default:
  385.         FATALTAG( e->tag );
  386.     }
  387. }
  388.  
  389. .endif
  390. .endforeach
  391. .foreach t $(need_fre_list)
  392. .set stic_$t "static "
  393. .endforeach
  394. .foreach t $(want_fre_list)
  395. .set stic_$t
  396. .endforeach
  397. .foreach t $(need_fre_list)
  398. /* Free a list of $t elements 'l'. */
  399. $(stic_$t)void fre_$t_list( l )
  400.  $t_list l;
  401. {
  402.     if( l == $t_listNIL ) return;
  403. .if $(statcode)
  404. #ifdef STAT
  405.     frecnt_$t_list++;
  406. #endif
  407. .endif
  408.     free( (char *) l->arr );
  409. #ifdef USECACHE
  410.     if( cacheix_$t_list<CACHESZ ){
  411.     cache_$t_list[cacheix_$t_list++] = l;
  412.     return;
  413.     }
  414. #endif
  415.     free( (char *) l );
  416. }
  417.  
  418. .endforeach
  419. /**************************************************
  420.  *    Append routines                             *
  421.  **************************************************/
  422.  
  423. .foreach t $(need_app_list)
  424. .set stic_$t "static "
  425. .endforeach
  426. .foreach t $(want_app_list)
  427. .set stic_$t
  428. .endforeach
  429. .foreach t $(need_app_list)
  430. /* Append a '$t' element 'e' to list 'l'. */
  431. $(stic_$t)void app_$t_list( l, e )
  432.  $t_list l;
  433.  $t e;
  434. {
  435.     if( l->sz >= l->room )
  436.     room_$t_list( l, (l->sz)+(l->sz) );
  437.     l->arr[l->sz] = e;
  438.     l->sz++;
  439. }
  440.  
  441. .endforeach
  442. /**************************************************
  443.  *    ins_<type>_list routines                    *
  444.  **************************************************/
  445.  
  446. .foreach t $(need_ins_list)
  447. .set stic_$t "static "
  448. .endforeach
  449. .foreach t $(want_ins_list)
  450. .set stic_$t
  451. .endforeach
  452. .foreach t $(need_ins_list)
  453. /* Insert a '$t' element 'e' into list 'l' at position 'pos'. */
  454. $(stic_$t)void ins_$t_list( l, pos, e )
  455.  register $t_list l;
  456.  unsigned int pos;
  457.  $t e;
  458. {
  459.     register unsigned int ix;
  460.  
  461.     if( l->sz >= l->room ){
  462.         room_$t_list( l, (l->sz)+(l->sz) );
  463.     }
  464.     if( pos > l->sz ) pos = l->sz;
  465.     for( ix=l->sz; ix>pos; ix-- ){
  466.         l->arr[ix] = l->arr[ix-1];
  467.     }
  468.     l->sz++;
  469.     l->arr[pos] = e;
  470. }
  471.  
  472. .endforeach
  473. /**************************************************
  474.  *    Concatenate routines                        *
  475.  **************************************************/
  476.  
  477. .foreach t $(need_conc_list)
  478. .set stic_$t "static "
  479. .endforeach
  480. .foreach t $(want_conc_list)
  481. .set stic_$t
  482. .endforeach
  483. .foreach t $(need_conc_list)
  484. /* Concatenate $t_list 'lb' after $t_list 'la'.
  485.    The list descriptor of 'lb' is freed,
  486.    since the contents has been moved to 'la'.
  487.  */
  488. $(stic_$t)void conc_$t_list( la, lb )
  489.  $t_list la;
  490.  $t_list lb;
  491. {
  492.     register unsigned int cnt;
  493.     register $t *sp;
  494.     register $t *dp;
  495.  
  496.     room_$t_list( la, la->sz+lb->sz );
  497.     cnt = lb->sz;
  498.     sp = lb->arr;
  499.     dp = &la->arr[la->sz];
  500.     while( cnt!=0 ){
  501.         *dp++ = *sp++;
  502.         cnt--;
  503.     }
  504.     la->sz += lb->sz;
  505.     fre_$t_list( lb );
  506. }
  507.  
  508. .endforeach
  509. /**************************************************
  510.  *    Recursive freeing routines                  *
  511.  **************************************************/
  512.  
  513. .. Forward declarations
  514. .foreach t $(need_rfre)
  515. .if ${index $t $(want_rfre)}
  516. .else
  517. static void rfre_$t();
  518. .endif
  519. .endforeach
  520. .foreach t $(need_rfre_list)
  521. .if ${index $t $(want_rfre_list)}
  522. .else
  523. static void rfre_$t_list();
  524. .endif
  525. .endforeach
  526.  
  527. .foreach t $(need_rfre)
  528. .set stic_$t "static "
  529. .endforeach
  530. .foreach t $(want_rfre)
  531. .set stic_$t
  532. .endforeach
  533. .foreach t $(need_rfre)
  534. /* Recursively free element 'e' of type '$t'
  535.    and all elements in it.
  536.  */
  537. .if ${strlen ${telmlist $t}}
  538. $(stic_$t)void rfre_$t( e )
  539.  $t e;
  540. {
  541.     if( e == $tNIL ) return;
  542. .foreach sname ${telmlist $t}
  543. .if ${eq list ${ttypeclass $t $(sname)}}
  544.     rfre_${ttypename $t $(sname)}_list( e->$(sname) );
  545. .else
  546.     rfre_${ttypename $t $(sname)}( e->$(sname) );
  547. .endif
  548. .endforeach
  549.     fre_$t( e );
  550. }
  551.  
  552. .else
  553. $(stic_$t)void rfre_$t( e )
  554.  $t e;
  555. {
  556.     if( e == $tNIL ) return;
  557.     switch( e->tag ){
  558. .foreach c ${conslist $t}
  559.         case TAG$c:
  560. .foreach sname ${celmlist $t $c}
  561. .if ${eq list ${ctypeclass $t $c $(sname)}}
  562.             rfre_${ctypename $t $c $(sname)}_list( (($c) e)->$(sname) );
  563. .else
  564.             rfre_${ctypename $t $c $(sname)}( (($c) e)->$(sname) );
  565. .endif
  566. .endforeach
  567.             break;
  568.  
  569. .endforeach
  570.         default:
  571.             FATALTAG( e->tag );
  572.     }
  573.     fre_$t( e );
  574. }
  575.  
  576. .endif
  577. .endforeach
  578. .foreach t $(need_rfre_list)
  579. .set stic_$t "static "
  580. .endforeach
  581. .foreach t $(want_rfre_list)
  582. .set stic_$t
  583. .endforeach
  584. .foreach t $(need_rfre_list)
  585. /* Recursively free a list of elements 'e' of type $t. */
  586. $(stic_$t)void rfre_$t_list( e )
  587.  $t_list e;
  588. {
  589.     unsigned int ix;
  590.  
  591.     if( e == $t_listNIL ) return;
  592.     for( ix=0; ix<e->sz; ix++ ) rfre_$t( e->arr[ix] );
  593.     fre_$t_list( e );
  594. }
  595.  
  596. .endforeach
  597. /**************************************************
  598.  *    print_<type> and print_<type>_list routines *
  599.  **************************************************/
  600.  
  601. .. Forward declarations
  602. .foreach t $(need_print)
  603. .if ${index $t $(want_print)}
  604. .else
  605. static void print_$t();
  606. .endif
  607. .endforeach
  608. .foreach t $(need_print_list)
  609. .if ${index $t $(want_print_list)}
  610. .else
  611. static void print_$t_list();
  612. .endif
  613. .endforeach
  614.  
  615. .foreach t $(need_print)
  616. .set stic_$t "static "
  617. .endforeach
  618. .foreach t $(want_print)
  619. .set stic_$t
  620. .endforeach
  621. .foreach t $(need_print)
  622. /* Print an element 't' of type '$t'
  623.    using print optimizer.
  624.  */
  625. $(stic_$t)void print_$t( t )
  626.  $t t;
  627. {
  628. .if ${strlen ${telmlist $t}}
  629.     if( t == $tNIL ){
  630.         printword( tm_niltxt );
  631.         return;
  632.     }
  633.     opentuple();
  634. .foreach sname ${telmlist $t}
  635. .if ${eq list ${ttypeclass $t $(sname)}}
  636.     print_${ttypename $t $(sname)}_list( t->$(sname) );
  637. .else
  638.     print_${ttypename $t $(sname)}( t->$(sname) );
  639. .endif
  640. .endforeach
  641.     closetuple();
  642. .else
  643.     if( t == $tNIL ){
  644.         printword( tm_niltxt );
  645.         return;
  646.     }
  647.     opencons();
  648.     switch( t->tag ){
  649. .foreach c ${conslist $t}
  650.         case TAG$c:
  651.             printword( "$c" );
  652. .foreach sname ${celmlist $t $c}
  653. .if ${eq list ${ctypeclass $t $c $(sname)}}
  654.             print_${ctypename $t $c $(sname)}_list( (($c) t)->$(sname) );
  655. .else
  656.             print_${ctypename $t $c $(sname)}( (($c) t)->$(sname) );
  657. .endif
  658. .endforeach
  659.             break;
  660.  
  661. .endforeach
  662.         default:
  663.             FATALTAG( t->tag );
  664.     }
  665.     closecons();
  666. .endif
  667. }
  668.  
  669. .endforeach
  670. .foreach t $(need_print_list)
  671. .set stic_$t "static "
  672. .endforeach
  673. .foreach t $(want_print_list)
  674. .set stic_$t
  675. .endforeach
  676. .foreach t $(need_print_list)
  677. /* Print a list of elements 'l' of type '$t'
  678.    using print optimizer.
  679.  */
  680. $(stic_$t)void print_$t_list( l )
  681.  $t_list l;
  682. {
  683.     unsigned int ix;
  684.  
  685.     if( l == $t_listNIL ){
  686.         printword( tm_niltxt );
  687.         return;
  688.     }
  689.     openlist();
  690.     for( ix=0; ix<l->sz; ix++ ) print_$t( l->arr[ix] );
  691.     closelist();
  692. }
  693.  
  694. .endforeach
  695. /***************************************************
  696.  *   fprint_<type> and fprint_<type>_list routines *
  697.  ***************************************************/
  698.  
  699. .. Forward declarations
  700. .foreach t $(need_fprint)
  701. .if ${index $t $(want_fprint)}
  702. .else
  703. static void fprint_$t();
  704. .endif
  705. .endforeach
  706. .foreach t $(need_fprint_list)
  707. .if ${index $t $(want_fprint_list)}
  708. .else
  709. static void fprint_$t_list();
  710. .endif
  711. .endforeach
  712.  
  713. .foreach t $(need_fprint)
  714. .set stic_$t "static "
  715. .endforeach
  716. .foreach t $(want_fprint)
  717. .set stic_$t
  718. .endforeach
  719. .foreach t $(need_fprint)
  720. /* Print an element 't' of type '$t'
  721.    to file 'f'.
  722.  */
  723. $(stic_$t)void fprint_$t( f, t )
  724.  FILE *f;
  725.  $t t;
  726. {
  727.     if( t == $tNIL ){
  728.         fprintf( f, tm_niltxt );
  729.         return;
  730.     }
  731.     putc( '(', f );
  732. .if ${strlen ${telmlist $t}}
  733. .set first 1
  734. .foreach sname ${telmlist $t}
  735. .if $(first)
  736. .set first 0
  737. .else
  738.     putc( ',', f );
  739. .endif
  740. .if ${eq list ${ttypeclass $t $(sname)}}
  741.     fprint_${ttypename $t $(sname)}_list( f, t->$(sname) );
  742. .else
  743.     fprint_${ttypename $t $(sname)}( f, t->$(sname) );
  744. .endif
  745. .endforeach
  746. .else
  747.     switch( t->tag ){
  748. .foreach c ${conslist $t}
  749.         case TAG$c:
  750.             fputs( "$c", f );
  751. .foreach sname ${celmlist $t $c}
  752.             putc( ' ', f );
  753. .if ${eq list ${ctypeclass $t $c $(sname)}}
  754.             fprint_${ctypename $t $c $(sname)}_list( f, (($c) t)->$(sname) );
  755. .else
  756.             fprint_${ctypename $t $c $(sname)}( f, (($c) t)->$(sname) );
  757. .endif
  758. .endforeach
  759.             break;
  760.  
  761. .endforeach
  762.         default:
  763.             FATALTAG( t->tag );
  764.     }
  765. .endif
  766.     fputs( ")\n", f );
  767. }
  768.  
  769. .endforeach
  770. .foreach t $(need_fprint_list)
  771. .set stic_$t "static "
  772. .endforeach
  773. .foreach t $(want_fprint_list)
  774. .set stic_$t
  775. .endforeach
  776. .foreach t $(need_fprint_list)
  777. /* Print a list of elements 'l' of type '$t'
  778.    to file 'f'.
  779.  */
  780. $(stic_$t)void fprint_$t_list( f, l )
  781.  FILE *f;
  782.  $t_list l;
  783. {
  784.     register unsigned int ix;
  785.  
  786.     if( l == $t_listNIL ){
  787.         fprintf( f, tm_niltxt );
  788.         return;
  789.     }
  790.     putc( '[', f );
  791.     for( ix=0; ix<l->sz; ix++ ){
  792.         if( ix!=0 ){
  793.             fputc( ',', f );
  794.         }
  795.         fprint_$t( f, l->arr[ix] );
  796.     }
  797.     fputs( "]\n", f );
  798. }
  799.  
  800. .endforeach
  801. /**************************************************
  802.  *    Duplication routines                        *
  803.  **************************************************/
  804.  
  805. .. Forward declarations
  806. .foreach t $(need_rdup)
  807. .if ${index $t $(want_rdup)}
  808. .else
  809. static $t rdup_$t();
  810. .endif
  811. .endforeach
  812. .foreach t $(need_rdup_list)
  813. .if ${index $t $(want_rdup_list)}
  814. .else
  815. static $t_list rdup_$t_list();
  816. .endif
  817. .endforeach
  818.  
  819. .foreach t $(need_rdup)
  820. .set stic_$t "static "
  821. .endforeach
  822. .foreach t $(want_rdup)
  823. .set stic_$t
  824. .endforeach
  825. .foreach t $(need_rdup)
  826. /* Recursively duplicate instance 'e' of type '$t' and
  827.  * all elements in it.
  828.  */
  829. $(stic_$t)$t rdup_$t( e )
  830.  $t e;
  831. {
  832. .if ${strlen ${telmlist $t}}
  833. .foreach e ${telmlist $t}
  834. .if ${eq list ${ttypeclass $t $e}}
  835.     ${ttypename $t $e}_list i_$e;
  836. .else
  837.     ${ttypename $t $e} i_$e;
  838. .endif
  839. .endforeach
  840.  
  841.     if( e == $tNIL ) return $tNIL;
  842. .foreach e ${telmlist $t}
  843. .if ${eq list ${ttypeclass $t $e}}
  844.     i_$e = rdup_${ttypename $t $e}_list( e->$e );
  845. .else
  846.     i_$e = rdup_${ttypename $t $e}( e->$e );
  847. .endif
  848. .endforeach
  849.     return new_$t( ${seplist ", " ${prefix "i_" ${telmlist $t}}} );
  850. .else
  851.     if( e == $tNIL ) return $tNIL;
  852.     switch( e->tag ){
  853. .foreach c ${conslist $t}
  854.         case TAG$c:
  855.         {
  856. .foreach e ${celmlist $t $c}
  857. .if ${eq list ${ctypeclass $t $c $e}}
  858.             ${ctypename $t $c $e}_list i_$e;
  859. .else
  860.             ${ctypename $t $c $e} i_$e;
  861. .endif
  862. .endforeach
  863.  
  864. .foreach e ${celmlist $t $c}
  865. .if ${eq list ${ctypeclass $t $c $e}}
  866.             i_$e = rdup_${ctypename $t $c $e}_list( (($c) e)->$e );
  867. .else
  868.             i_$e = rdup_${ctypename $t $c $e}( (($c) e)->$e );
  869. .endif
  870. .endforeach
  871.             return new_$c( ${seplist ", " ${prefix "i_" ${celmlist $t $c}}} );
  872.         }
  873.  
  874. .endforeach
  875.         default:
  876.             FATALTAG( e->tag );
  877.     }
  878.     return $tNIL;
  879. .endif
  880. }
  881.  
  882. .endforeach
  883. .foreach t $(need_rdup_list)
  884. .set stic_$t "static "
  885. .endforeach
  886. .foreach t $(want_rdup_list)
  887. .set stic_$t
  888. .endforeach
  889. .foreach t $(need_rdup_list)
  890. /* Recursively duplicate an instance 'e' of a '$t' list */
  891. $(stic_$t)$t_list rdup_$t_list( e )
  892.  $t_list e;
  893. {
  894.     unsigned int ix;
  895.     $t_list new;
  896.  
  897.     new = new_$t_list();
  898.     room_$t_list( new, e->sz );
  899.     for( ix=0; ix<e->sz; ix++ ){
  900.         app_$t_list( new, rdup_$t( e->arr[ix] ) );
  901.     }
  902.     return new;
  903. }
  904.  
  905. .endforeach
  906. /*********************************************************
  907.  *    cmp_<type> and cmp_<type>_list routines            *
  908.  *********************************************************/
  909.  
  910. .. Forward declarations
  911. .foreach t $(need_cmp)
  912. .if ${index $t $(want_cmp)}
  913. .else
  914. static int cmp_$t();
  915. .endif
  916. .endforeach
  917. .foreach t $(need_cmp_list)
  918. .if ${index $t $(want_cmp_list)}
  919. .else
  920. static int cmp_$t_list();
  921. .endif
  922. .endforeach
  923.  
  924. .foreach t $(need_cmp)
  925. .if ${index $t $(want_cmp)}
  926. .set stat
  927. .else
  928. .set stat "static "
  929. .endif
  930. .if ${len ${telmlist $t}}
  931. .. cmp tuple
  932. /* Compare two $t tuples 'a' and 'b'. */
  933. $(stat)int cmp_$t( a, b )
  934.  register $t a;
  935.  register $t b;
  936. {
  937.     register int res;
  938.  
  939.     res = 0;
  940. .set first 1
  941. .foreach ename ${telmlist $t}
  942. .if ${eq list ${ttypeclass $t $(ename)}}
  943. .set tn ${ttypename $t $(ename)}_list
  944. .else
  945. .set tn ${ttypename $t $(ename)}
  946. .endif
  947. .if $(first)
  948. .set first 0
  949. .else
  950.     if( res != 0 ) return res;
  951. .endif
  952.     res = cmp_$(tn)( a->$(ename), b->$(ename) );
  953. .endforeach
  954.     return res;
  955. }
  956.  
  957. .else
  958. .. cmp constructor
  959. /* Compare two $t constructors 'a' and 'b'. */
  960. $(stat)int cmp_$t( a, b )
  961.  $t a;
  962.  $t b;
  963. {
  964.     register int res;
  965.  
  966.     res = ((int)a->tag - (int)b->tag);
  967.     if( res != 0 ) return res;
  968.     switch( a->tag )
  969.     {
  970. .foreach c ${conslist $t}
  971.     case TAG$c:
  972. .set first 1
  973. .foreach ename ${celmlist $t $c}
  974. .if ${eq list ${ctypeclass $t $c $(ename)}}
  975. .set tn ${ctypename $t $c $(ename)}_list
  976. .else
  977. .set tn ${ctypename $t $c $(ename)}
  978. .endif
  979. .if $(first)
  980. .set first 0
  981. .else
  982.         if( res != 0 ) break;
  983. .endif
  984.         res = cmp_$(tn)( (($c) a)->$(ename), (($c) b)->$(ename) );
  985. .endforeach
  986.         break;
  987.  
  988. .endforeach
  989.         default:
  990.         FATALTAG( a->tag );
  991.     }
  992.     return res;
  993. }
  994.  
  995. .endif
  996. .endforeach
  997. .foreach t $(need_cmp_list)
  998. .if ${index $t $(want_cmp_list)}
  999. .set stat
  1000. .else
  1001. .set stat "static "
  1002. .endif
  1003. /* Compare two $t lists 'a' and 'b'. */
  1004. $(stat)int cmp_$t_list( a, b )
  1005.  register $t_list a;
  1006.  register $t_list b;
  1007. {
  1008.     register int res;
  1009.     register unsigned int ix;
  1010.  
  1011.     ix = 0;
  1012.     while( ix<a->sz || ix<b->sz ){
  1013.     if( ix>=a->sz ) return -1;
  1014.     if( ix>=b->sz ) return 1;
  1015.     res = cmp_$t( a->arr[ix], b->arr[ix] );
  1016.     if( res != 0 ) return res;
  1017.     ix++;
  1018.     }
  1019.     return 0;
  1020. }
  1021.  
  1022. .endforeach
  1023. /**************************************************
  1024.  *    Scan routines                               *
  1025.  **************************************************/
  1026.  
  1027. .. Forward declarations
  1028. .foreach t $(need_fscan)
  1029. .if ${index $t $(want_fscan)}
  1030. .else
  1031. static int fscan_$t();
  1032. .endif
  1033. .endforeach
  1034. .foreach t $(need_fscan_list)
  1035. .if ${index $t $(want_fscan_list)}
  1036. .else
  1037. static int fscan_$t_list();
  1038. .endif
  1039. .endforeach
  1040.  
  1041. .foreach t $(need_fscan)
  1042. .set stic_$t "static "
  1043. .endforeach
  1044. .foreach t $(want_fscan)
  1045. .set stic_$t
  1046. .endforeach
  1047. .foreach t $(need_fscan)
  1048. .if ${strlen ${telmlist $t}}
  1049. /* Read a tuple of type $t
  1050.    from file 'f' and allocate space for it.
  1051.    Set the pointer 'p' to point to that structure.
  1052.  */
  1053. $(stic_$t)int fscan_$t( f, p )
  1054.  FILE *f;
  1055.  $t *p;
  1056. {
  1057.     register short int err;
  1058. .foreach ename ${telmlist $t}
  1059. .if ${eq list ${ttypeclass $t $(ename)}}
  1060. .set tn ${ttypename $t $(ename)}_list
  1061. .else
  1062. .set tn    ${ttypename $t $(ename)}
  1063. .endif
  1064.     $(tn) l_$(ename);
  1065. .endforeach
  1066.  
  1067. .foreach ename ${telmlist $t}
  1068. .if ${eq list ${ttypeclass $t $(ename)}}
  1069. .set tn ${ttypename $t $(ename)}_list
  1070. .else
  1071. .set tn    ${ttypename $t $(ename)}
  1072. .endif
  1073.     l_$(ename) = $(tn)NIL;
  1074. .endforeach
  1075.     err = tmfneedc( f, '(' );
  1076.     if( err ) return 1;
  1077. .set first 1
  1078. .foreach ename ${telmlist $t}
  1079. .if ${eq list ${ttypeclass $t $(ename)}}
  1080. .set tn ${ttypename $t $(ename)}_list
  1081. .else
  1082. .set tn    ${ttypename $t $(ename)}
  1083. .endif
  1084. .if $(first)
  1085. .set first 0
  1086. .else
  1087.     if( !err ) err = tmfneedc( f, ',' );
  1088. .endif
  1089.     if( !err ) err = fscan_$(tn)( f, &l_$(ename) );
  1090. .endforeach
  1091.     *p = new_$t( ${seplist ", " ${prefix " l_" ${telmlist $t}}} );
  1092.     if( err ) return 1;
  1093.     return tmfneedc( f, ')' );
  1094. }
  1095.  
  1096. .else
  1097. /* Read an instance of a datastructure of type $t.
  1098.    from file 'f' and allocate space for it. Set the pointer 'p' to
  1099.    point to that structure.
  1100.  */
  1101. $(stic_$t)int fscan_$t( f, p )
  1102.  FILE *f;
  1103.  $t *p;
  1104. {
  1105.     register int n;
  1106.     char tm_word[WORDBUFSIZE];
  1107.     register short int err = 0;
  1108.  
  1109.     n = fscanopenbrac( f );
  1110.     if( fscancons( f, tm_word ) ){
  1111.         *p = $tNIL;
  1112.         return 1;
  1113.     }
  1114. .. First time in loop there should be no 'else' before the if,
  1115. .. in all other cases there should.
  1116. .set els
  1117. .foreach c ${conslist $t}
  1118.     $(els)if( strcmp( tm_word, "$c" ) == 0 ){
  1119. .foreach ename ${celmlist $t $c}
  1120. .if ${eq list ${ctypeclass $t $c $(ename)}}
  1121. .set tn ${ctypename $t $c $(ename)}_list
  1122. .else
  1123. .set tn    ${ctypename $t $c $(ename)}
  1124. .endif
  1125.         $(tn) l_$(ename);
  1126. .endforeach
  1127.  
  1128. .foreach ename ${celmlist $t $c}
  1129. .if ${eq list ${ctypeclass $t $c $(ename)}}
  1130. .set tn ${ctypename $t $c $(ename)}_list
  1131. .else
  1132. .set tn    ${ctypename $t $c $(ename)}
  1133. .endif
  1134.         l_$(ename) = $(tn)NIL;
  1135.         if( !err) err = fscan_$(tn)( f, &l_$(ename) );
  1136. .endforeach
  1137.         *p = new_$c( ${seplist ", " ${prefix " l_" ${celmlist $t $c}}} );
  1138.     }
  1139. .set els "else "
  1140. .endforeach
  1141.     else {
  1142.         (void) sprintf( tmerrmsg, tm_badcons, "$t", tm_word );
  1143.         return 1;
  1144.     }
  1145.     if( err ) return 1;
  1146.     return fscanclosebrac( f, n );
  1147. }
  1148.  
  1149. .endif
  1150. .endforeach
  1151. .foreach t $(need_fscan_list)
  1152. .set stic_$t "static "
  1153. .endforeach
  1154. .foreach t $(want_fscan_list)
  1155. .set stic_$t
  1156. .endforeach
  1157. .foreach t $(need_fscan_list)
  1158. /* Read an instance of a list of datastructure of type $t.
  1159.    from file 'f' and allocate space for it. Set the pointer 'p' to
  1160.    point to that structure.
  1161.  */
  1162. $(stic_$t)int fscan_$t_list( f, p )
  1163.  FILE *f;
  1164.  $t_list *p;
  1165. {
  1166.     register short int err = 0;
  1167.     register int c;
  1168.     int n;
  1169.     $t new;
  1170.  
  1171.     *p = new_$t_list();
  1172.     n = fscanopenbrac( f );
  1173.     if( tmfneedc( f, '[' ) ) return 1;
  1174.     if( fscanspace( f ) ) return 1;
  1175.     c = getc( f );
  1176.     if( c == ']' ) return 0;
  1177.     if( c == EOF ){
  1178.         (void) strcpy( tmerrmsg, tm_badeof );
  1179.         return 1;
  1180.     }
  1181.     ungetc( c, f );
  1182.     while( 1 ){
  1183.         if( !err ) err = fscan_$t( f, &new );
  1184.         app_$t_list( *p, new );
  1185.         if( err || fscanspace( f ) ) return 1;
  1186.         c = getc( f );
  1187.         if( c == EOF ){
  1188.             (void) strcpy( tmerrmsg, tm_badeof );
  1189.             return 1;
  1190.         }
  1191.         if( c != ',' ){
  1192.             ungetc( c, f );
  1193.             break;
  1194.         }
  1195.     }
  1196.     if( tmfneedc( f, ']' ) ) return 1;
  1197.     return fscanclosebrac( f, n );
  1198. }
  1199.  
  1200. .endforeach
  1201. /**************************************************
  1202.  *    del_<type>_list routines                    *
  1203.  **************************************************/
  1204.  
  1205. .foreach t $(need_del_list)
  1206. .set stic_$t "static "
  1207. .endforeach
  1208. .foreach t $(want_del_list)
  1209. .set stic_$t
  1210. .endforeach
  1211. .foreach t $(need_del_list)
  1212. /* Delete '$t' element at position 'pos' in list 'l'. */
  1213. $(stic_$t)void del_$t_list( l, pos )
  1214.  register $t_list l;
  1215.  unsigned int pos;
  1216. {
  1217.     register unsigned int ix;
  1218.  
  1219.     if( pos >= l->sz ) return;
  1220.     rfre_$t( l->arr[pos] );
  1221.     l->sz--;
  1222.     for( ix=pos; ix<l->sz; ix++ ){
  1223.         l->arr[ix] = l->arr[ix+1];
  1224.     }
  1225. }
  1226.  
  1227. .endforeach
  1228. /************************************************************
  1229. *    Miscellaneous routines                                 *
  1230. ************************************************************/
  1231. .if ${index flush_$(basename) $(need_misc)}
  1232. /* Flush the allocation caches. */
  1233. void flush_$(basename)()
  1234. {
  1235. #ifdef USECACHE
  1236.     register short int ix;
  1237. .foreach t ${uniq $(need_new_list) $(need_fre_list)}
  1238.     for( ix=0; ix<cacheix_$t_list; ix++ ){
  1239.     free( (char *) cache_$t_list[ix] );
  1240.     }
  1241.     cacheix_$t_list = 0;
  1242. .endforeach
  1243. .foreach t ${uniq $(need_new) $(need_fre)}
  1244. .if ${strlen ${telmlist $t}}
  1245.     for( ix=0; ix<cacheix_$t; ix++ ){
  1246.     free( (char *) cache_$t[ix] );
  1247.     }
  1248.     cacheix_$t = 0;
  1249. .else
  1250. .foreach c ${conslist $t}
  1251.     for( ix=0; ix<cacheix_$c; ix++ ){
  1252.     free( (char *) cache_$c[ix] );
  1253.     }
  1254.     cacheix_$c = 0;
  1255. .endforeach
  1256. .endif
  1257. .endforeach
  1258. #endif
  1259. }
  1260.  
  1261. .endif
  1262. .if $(statcode)
  1263. /* Give statistics. */
  1264. void stat_$(basename)( f )
  1265.  FILE *f;
  1266. {
  1267. #ifdef STAT
  1268. .foreach t $(need_stat_list)
  1269.     fprintf( f, tm_allocfreed, "[$t]", newcnt_$t_list, frecnt_$t_list, hitcnt_$t_list, ((newcnt_$t_list==frecnt_$t_list)? "": "<-") );
  1270. .endforeach
  1271. .foreach t $(need_stat)
  1272. .if ${strlen ${telmlist $t}}
  1273.     fprintf(f,tm_allocfreed,"$t",newcnt_$t,frecnt_$t,hitcnt_$t,((newcnt_$t==frecnt_$t)? "": "<-") );
  1274. .else
  1275. .foreach c ${conslist $t}
  1276.     fprintf(f,tm_allocfreed,"$c",newcnt_$c,frecnt_$c,hitcnt_$c,((newcnt_$c==frecnt_$c)? "": "<-") );
  1277. .endforeach
  1278. .endif
  1279. .endforeach
  1280. #else
  1281.     f = f; /* to prevent 'f unused' from compiler and lint */
  1282. #endif
  1283. }
  1284.  
  1285. .endif
  1286. /* ---- end of ${tplfilename} ---- */
  1287.  
  1288.